home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / atutr202.zip / janus.ada < prev    next >
Text File  |  1992-09-04  |  3KB  |  60 lines
  1. -- JANUS.ADA   Ver. 2.02   4-SEP-1992   Copyright 1988-1992 John J. Herro
  2. -- Software Innovations Technology
  3. -- 1083 Mandarin Drive NE, Palm Bay, FL  32905-4706   (407)951-0233
  4. --
  5. -- Compile this before compiling ADA_TUTR.ADA, when using a PC with Janus/Ada.
  6. --
  7. with TEXT2_IO; use TEXT2_IO;
  8. package CUSTOM_IO is
  9.    type COLOR is (BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE);
  10.    FOREGRND_COLOR   : COLOR := WHITE;                 -- Default values in case
  11.    BACKGRND_COLOR   : COLOR := BLACK;                 -- ADA-TUTR finds no User
  12.    BORDER_COLOR     : COLOR := BLACK;                 -- File.
  13.    FORE_COLOR_DIGIT : CHARACTER := CHARACTER'VAL(COLOR'POS(FOREGRND_COLOR)+48);
  14.    BACK_COLOR_DIGIT : CHARACTER := CHARACTER'VAL(COLOR'POS(BACKGRND_COLOR)+48);
  15.    NORMAL_COLORS    : STRING(1 .. 10) := ASCII.ESC & "[0;3" &
  16.                             FORE_COLOR_DIGIT & ";4" & BACK_COLOR_DIGIT & "m";
  17.    CLEAR_SCRN       : constant STRING := ASCII.ESC & "[H" & ASCII.ESC &"[2J";
  18.  
  19.    procedure SET_BORDER_COLOR (TO   : In COLOR);
  20.    procedure GET              (CHAR : out CHARACTER);
  21.    procedure PUT              (CHAR : in  CHARACTER) renames TEXT2_IO.PUT;
  22.    procedure PUT              (STR  : in  STRING)    renames TEXT2_IO.PUT;
  23.    procedure PUT_LINE         (STR  : in  STRING)    renames TEXT2_IO.PUT_LINE;
  24.    procedure GET_LINE         (STR  : out STRING;
  25.                                LAST : out NATURAL)   renames TEXT2_IO.GET_LINE;
  26.    procedure NEW_LINE(SPACING : in POSITIVE_COUNT := 1)
  27.                                                      renames TEXT2_IO.NEW_LINE;
  28. end CUSTOM_IO;
  29.  
  30. with DOSCALL, SYSTEM; use DOSCALL, SYSTEM;
  31. package body CUSTOM_IO is
  32.     procedure SET_BORDER_COLOR(TO : in COLOR) is
  33.         --
  34.         -- This procedure sets the border color on a PC by calling interrupt
  35.         -- 10 hex.  Before the call, register AH is set to service number
  36.         -- 0B hex, BH is set to zero, and BL is set to an integer as shown in
  37.         -- the declaration of Color_Number below.  Note that the integers in
  38.         -- Color_Number are bit reversed from the integers defining foreground
  39.         -- and background colors in ANSI escape sequences.  Note also that some
  40.         -- color PCs don't have separate border colors.
  41.         --
  42.         REGS         : SIMPLE_REGS;
  43.         COLOR_NUMBER : constant array(COLOR) of SYSTEM.WORD :=
  44.             (BLACK   => 0,   RED     => 4,   GREEN   => 2,   YELLOW  => 6,
  45.              BLUE    => 1,   MAGENTA => 5,   CYAN    => 3,   WHITE   => 7);
  46.     begin
  47.         REGS.AX := 16#0B00#;
  48.         REGS.BX := 16#0000# + Color_Number(To);
  49.         SIMPLE_INT_CALL(INT_NUM => 16#10#, REGS => REGS);
  50.     end SET_BORDER_COLOR;
  51.  
  52.     procedure GET(CHAR : out CHARACTER) is
  53.         REGS : SIMPLE_REGS;
  54.     begin
  55.         REGS.AX := 16#0800#;
  56.         SIMPLE_INT_CALL(INT_NUM => 16#21#, REGS => REGS);
  57.         CHAR := CHARACTER'VAL(REGS.AX mod 128);
  58.     end GET;
  59. end CUSTOM_IO;
  60.